Shareware Grab Bag/Shareware Grab Bag.iso/013/td3.arc/TD3.PAS

Pascal/Delphi Source File | 1986-04-25 | 31.5 KB | 1,347 lines

{$R-,C-,U-}
program td;
   { version 3.12  Copright (c) 1986 by Mark Johnson 04/24/86           }
   { Mark E. Johnson                 2272-F Benson Avenue               }
   {                                 St. Paul Minnesota  55116          }
   { evening phone                   612-698-3686                       }

{ 3/15/86 - Text foreground colors added for IBM PC   }
{ 3/15/86 - Table is now in record format             }
{ 3/17/86 - Added windows, sound (errors cause beep)  }
{ 4/20/86 - Pull-Down windows added                   }

const

  MaxItems=20; {Max Items on a Menu Bar}
  MaxMenus=10; {Max Menus}
  Width=11;    {Width of Pull Down Fields}

  TBL_LEN = 80;  { maximum number of elements in report }

type
  names        = string[80];
  ltype        = string[85];
  stype        = string[10];

  fieldrec     = record         { format of each report field }
        rtype     : char;       { N)umeric, A)lpha, or L)iteral }
        rio       : char;       { IO type, I)nput or O)utput  }
        rname     : ltype;      { Field name                  }
        rx        : integer;    { Line number                 }
        ry        : integer;    { Column number               }
        rlen      : integer;    { Length of field             }
        rscale    : integer;    { Number of decimal places    }
        rfgnd     : integer;    { forground color             }
        rorder    : integer;    { Sequence number (for sort)  }
  end;

   VideoMode =(Norm,Rev,Hi,Und,RevHi,Blink,BlinkHi,RevBlink,RevBlinkHi);
   MaxString = String[255];
   stringW = string[Width];

   ProtoMenu = record
       NumEntry :array[0..MaxItems] of integer;
       Menu:array[0..MaxItems] of array[0..MaxItems] of stringW;
       MenuName:stringW;
       NoItems:integer;
   end;

   MenuPtr = ^ProtoMenu;
   MenuAry =  array[1..MaxMenus] of MenuPtr;

var
    junk      : char;
    special   : boolean; { last character was special}

    fields    : array[1..TBL_LEN] of fieldrec;

    ndx       : integer;       { Position in Fields Table }
    line      : ltype;         { input line for INFILE    }
    lineno    : integer;       { The line we're on        }
    colno     : integer;       { The column we're at      }
    token     : ltype;         { used by parser           }
    tail      : string[32];    { used by code generator   }
    i,j,l     : integer;       { Misc. loop controls      }
    incr      : integer;       { Field number increment   }
    outtype   : char;          { Field output type        }
    ans       : char;          { Query variable           }
    infile    : text;          { input file               }
    outfile   : text;          { output file              }
    libfile   : text;          { library                  }
    procname  : string[32];    { name of procedure        }
    varfl     : boolean;       { include variable declarations? }
    librfl    : boolean;       { include library file?    }
    subrfl    : boolean;       { Write file as subroutine procedure? }
    ctemp     : stype;
    efile     : boolean;       { End of file flag         }
    level     : integer;
    inname    : string[15];    { SCR file name            }
    outname   : string[15];    { PAS file name            }
    libname   : string[15];    { LIB file name            }
    lastcolor : integer;       { Current text color       }

    NumMenus  :integer;
    Menus     :MenuAry;
    exit      :boolean;
    VideoSeg  :integer;{points to $B000 or $B800  for color or mono}
    botbox    :maxstring;

    active,index,item,entry : integer;

label
    generate, retry, endinp;


function ColorMonitor:boolean;
{returns TRUE if a Color monitor is installed}
type regpack = record
       ax,bx,cx,dx,bp,si,di,ds,es,flags:integer;end;
var regs:regpack;
   al:integer;
begin
  regs.ax:=15 shl 8;
  intr($10,regs);
  al:=Lo(regs.ax);
  if al=$7 then ColorMonitor:=false else ColorMonitor:=true;
end;


Procedure SetVideoSeg;
begin
  if colormonitor then VideoSeg:=$B800 else VideoSeg:=$B000
end;


Procedure SetCursor(HiScan,LowScan:byte);
type regpack = record
       ax,bx,cx,dx,bp,si,di,ds,es,flags:integer;end;
var regs:regpack;
begin
  regs.ax:=1 shl 8;
  regs.cx:=HiScan shl 8 + LowScan;
  intr($10,regs);
end;


Procedure CursorNormal;
begin
  if ColorMonitor then SetCursor(6,7) else  SetCursor(10,11);
end;


Procedure CursorBlock;
begin
  if ColorMonitor then SetCursor(1,7) else  SetCursor(1,14);
end;


Procedure CursorOff;
begin
  SetCursor(31,0);
end;

procedure GetKb(var chcode,extcode:integer);

(*Obtains the character and extended codes of a struck key. The codes are
 removed from the buffer. This procedure will wait for a keystrike if the
 buffer is empty.*)

type
  RegPack = record
      ax,bx,cx,dx,di,si,ds,es,flags : integer;
  end;
var
  regs:RegPack;

begin
  regs.ax := $0000;
  intr($16,regs);
  extcode := regs.ax shr 8;     (*extended  code is AH*)
  chcode := regs.ax and $00FF;  (*character code is AL*)
end;


function inchar(var ch:char;var ex:integer):boolean;{true if ASCII char}
{Returns char and extended code from keyboard}
var chcode,excode:integer;

begin
getkb(chcode,ex);
if chcode=0 then
    begin
    inchar:=false;
    ch:=chr(ex);
    end
else
    begin
    ch:=chr(chcode);
    inchar:=true;
    if ex<>0 then
      if chcode in [8,13,9,27] then
      begin
        ex:=chcode;
        inchar:=false;
      end;
    end;
end;{inchar}

procedure WriteAt(x,y:integer;WriteMode:VideoMode;TheString:maxstring);
{Memory Mapped write}
Var
  i,j,k:integer;
  Attribute:Byte;

Begin{1}
  case WriteMode of {change these for color terminals}
   Norm:       Attribute := $07;
   Rev:        Attribute := $70;
   Hi:         Attribute := $0F;
   Und:        Attribute := $01;
   RevHi:      Attribute := $78;
   Blink:      Attribute := $87;
   BlinkHi:    Attribute := $8F;
   RevBlink:   Attribute := $F0;
   RevBlinkHi: Attribute := $F8;
   ELSE        Attribute := $07;{Normal}
   end;

   j := 2*((y-1)*80+(x-1));{offset in video buffer}
   i:=1;
   k:=length(thestring);
   While i<=k do
       begin
       Mem[VideoSeg : j] := Byte(TheString[i]);
       Mem[VideoSeg : (j+1)] := Attribute;
       i:=i+1;
       j:=j+2;
       end;
end;              {1 of WriteAt}


Procedure LoadMenus(var MenuList:MenuAry);
{loads the menu data file}
var i,j,k:integer;
    f:text;
    s:maxstring;

Procedure GetAMenu(var M:MenuPtr);
label 99;
var i,j,k:integer;
begin
i:=-1;
j:=0;
{ s has been primed }
M^.MenuName:=s;
readln(f,s);
s:=s+'            ';
while (s[1]<>'*') and (not eof(f)) do
   begin

   if s[1]<>' ' then
     begin
     if i>=0 then M^.NumEntry[i]:=j;
     i:=i+1;
     M^.Menu[i,0]:=s;
     j:=0;
     end

   else
     if s[1]<>'*' then
       begin
       j:=j+1;
       delete(s,1,1);
       M^.Menu[i,j]:=s;
       end
     else goto 99;

  readln(f,s);
  s:=s+'            ';

  end;

99:
M^.NumEntry[i]:=j;
M^.NoItems:=i;

end;{GetAMenu}

begin{Load}

assign(f,'td.dat'); {alter name for application}
reset(f);

i:=0;
readln(f,s);

while not eof(f) do
   begin
   i:=i+1;
   New(Menus[i]);
   GetAMenu(Menus[i]);
   end;
NumMenus:=i;

close(f);

{some other initialization here}

botbox:='╚';
for i:=1 to Width do botbox:=botbox+'═';
botbox:=botbox+'╝';

end;{LoadMenu}


procedure DoMenu(var itemsel,entrysel:integer;M:MenuPtr);

  {this runs a menu, reads keys etc,}
  {itemsel and entrysel are returned}

type
   setofkeys=set of 0..132;

var
   chc,ex:integer;
   ch:char;
   validkeys:setofkeys;
   asc,selection:boolean;
   item,entry:integer;
   s1,s2:maxstring;


Procedure PaintMenuBar;
var
  i,sx:integer;

begin
writeat(1,1,rev,
'                                                                                ');
for i:=0 to M^.NoItems do
   begin
   sx:=2+i*Width;
   writeat(sx,1,rev,M^.Menu[i,0]);
   end;
end;{PaintMenuBar}


Procedure Bright(ix,ij:integer);
var sx:integer;
    s:maxstring;

begin
  s:=M^.Menu[ix,ij];
  sx:=ix*Width+1;
  writeat(sx+1,ij+1,Rev,s)
end;


Procedure UnderScore(ix,ij:integer);
var sx:integer;
    s:maxstring;

begin
  sx:=ix*Width+1;
  s:=M^.Menu[ix,ij];
  writeat(sx+1,ij+1,Und,s)
end;


Procedure Normal(ix,ij:integer);
var sx:integer;
    s:maxstring;

begin
  sx:=ix*Width+1;
  if ij=0 then if sx<1 then sx:=1;
  s:=M^.Menu[ix,ij];
  writeat(sx+1,ij+1,Norm,s);
end;


Procedure PushUp(ix:integer);
var sx,i:integer;

begin
  sx:=ix*Width+1;
  if sx<1 then sx:=1;
  for i:=1 to M^.NumEntry[ix]+1 do
     writeat(sx,i+1,Norm,'             ');
end;

Procedure PullDown(ix:integer);
const

    l:maxstring='║';
    r:maxstring='║';

var sx:integer;
    s:maxstring;
    j:integer;

begin
sx:=ix*Width+1;
for j:=1 to M^.NumEntry[ix] do
    begin
    s:=l+M^.Menu[ix,j]+r;
    writeat(sx,j+1,Norm,s);
    end;
if M^.NumEntry[ix]>0 then writeat(sx,M^.NumEntry[ix]+2,Norm,botbox);
end;


begin {DoMenu}

CursorOff;

validkeys:=[13,15,75,9,77,80,72,27];

entry:=1;
item:=0;
PaintMenuBar;
PullDown(0);
Bright(item,entry);

selection:=FALSE;

while not selection do
   begin

   asc:= Inchar(ch,ex);

   if ex=0 then {Ctl-Brk hit}
   begin
      CursorNormal;
      clrscr;
      halt;
   end;

   if not asc then
   case ex{tended code} of

   13:{CR}
      selection:=TRUE;


      15, 75:{lefttab,left}
      if item>0 then
      begin
        item:=item-1;
        entry:=1;
        pushup(item+1);
        pulldown(item);
        Bright(item,entry);
      end;

       9, 77:{tab,right}
      if item<M^.NoItems then
        begin
        item:=item+1;
        entry:=1;
        pushup(item-1);
        pulldown(item);
        entry:=1;
        Bright(item,1);
      end;

  80:{down}
      begin
        if entry<M^.NumEntry[item] then
        begin
          entry:=entry+1;
          Normal(item,entry-1);
          Bright(item,entry);
        end
        else
        begin
          entry:=1;
          Normal(item,M^.NumEntry[item]);
          Bright(item,entry);
        end;
      end;

 72:{up}
     begin
       if entry>1 then
       begin
         entry:=entry-1;
         Normal(item,entry+1);
         Bright(item,entry);
       end
       else
       begin
         entry:=M^.NumEntry[item];
         Normal(item,1);
         Bright(item,entry);
       end;
     end;
 27:{Esc}
     begin
       selection:=TRUE;
       item:=0;
       entry:=0;
     end;

 end;{case}

end;{while not selection}
itemsel:=item;
entrysel:=entry;

CursorNormal;

end;   {DoMenu}

{ End of Pull-Down Window routines }


                     { start  start  end    end    color  color }
                     { col    line   col    line   fgnd   bgnd  }
Procedure drawbox_ibm (x1,    y1,    x2,    y2,    FG,    BG : Integer;
                       boxname : names; blnk : boolean);
var
  q : integer;
  x : integer;
Begin
  window (x1,y1,x2,y1+1);
  textbackground(BG);
  GotoXY(1,1);
  x := x2-x1;
  if length(boxname) > x then boxname[0] := chr(x-4);
  textcolor(FG);
  Write('╒');
  textcolor(fg);
  write (boxname);
  textcolor(FG);
  for q := x1+length(boxname)+1 to x2-1 do Write('═');
  Write('╕');
  for q := 2 to y2-y1 do
    Begin
      window (x1,y1,x2,y1+q+1);
      GotoXY(1,q); Write('│');
      if blnk then clreol;
      GotoXY(x2-x1+1,q); Write('│');
    end;
  Window(x1,y1,x2,y2+1);
  gotoXY(1,y2-y1+1);
  Write('╘');
  for q := x1+1 to x2-1 do Write('═');
  Write('╛');
end;

Procedure drawbox (x1,y1,x2,y2,FG,BG : Integer;
                   boxname : Names; blnk : boolean);
Begin
  Drawbox_IBM (x1,y1,x2,y2,FG,BG,boxname,blnk);
  Window (x1+1,y1+1,x2-1,y2-1);
  Clrscr;
end;


procedure beep;
var
   i    : integer;
   tone : integer;
begin

  tone:=200;
  for i:=1 to 50 do
  begin
    sound(tone);
    delay(1);
    tone:=tone+10;
  end;
  nosound;
end;

{ The following are proprietory routines for TD.PAS }

function toupper(mess : ltype) : ltype;   { convert string to upper case }
var
  temp : ltype;
  i    : integer;

begin
  temp:='';
  for i:=1 to length(mess) do
    temp:=concat(temp,upcase(copy(mess,i,1)));
  toupper:=temp;
end;

function convert(num : integer) : stype;   { convert integer to string }
var
  st1  : stype;

begin
  str(num,st1);
  while copy(st1,1,1) = ' ' do
    st1:=copy(st1,2,length(st1)-1);
  convert:=st1;
end;

procedure spread(c : char; l : integer);   { display specified # of characters }
var
 i : integer;
 begin
   for i:=1 to l do
     write(c);
 end;

procedure display_screen;  { display input file as a screen }
var
  i     : integer;
  pause : char;
  fgnd  : integer;

begin
  clrscr;
  for i := 1 to ndx-1 do
  begin
    gotoxy(fields[i].ry,fields[i].rx);
    fgnd:=fields[i].rfgnd;
    textcolor(fgnd);
    if fields[i].rtype <> 'L' then
    begin
      if fields[i].rtype = 'A' then
        spread('X',fields[i].rlen)
      else
      begin
        spread('9',fields[i].rlen-fields[i].rscale);
        if fields[i].rscale > 0 then
        begin
          write('.');
          spread('9',fields[i].rscale);
        end;
      end;
    end
    else
      write(fields[i].rname);
  end;
end;

procedure setup;    { prompt for and accept changes to screen }
var
  ans    : char;
  iotype : string[8];
  ftype  : char;
  ch     : char;

begin
  active := 1;
  i := 1;
  if fields[i].rtype = 'L' then
  begin
    repeat
      i:=i+1;
    until fields[i].rtype <> 'L';
  end;
  while i < ndx do
  begin
    display_screen;
    gotoxy(fields[i].ry,fields[i].rx);
    textcolor(fields[i].rfgnd+16);
    if fields[i].rtype <> 'L' then
    begin
      if fields[i].rtype = 'A' then
        spread('X',fields[i].rlen)
      else
      begin
        spread('9',fields[i].rlen-fields[i].rscale);
        if fields[i].rscale > 0 then
        begin
          write('.');
          spread('9',fields[i].rscale);
        end;
      end;
    end
    else
      write(fields[i].rname);
    textcolor(15);

    domenu(item,entry,menus[active]);
    index := active * 100 + item * 10 + entry;
    gotoxy(1,23);
    case index of

        101 :           { Next item }
        begin
          repeat
            i := i + 1;
          until (fields[i].rtype <> 'L') or (i >= ndx);
        end;

        102 :           { Return to main menu }
          i := ndx + 1;

        111:            { Alpha mode }
          fields[i].rtype := 'A';

        112:            { Numeric mode }
          fields[i].rtype := 'N';

        121:            { Length }
        begin
          gotoxy(1,1);
          write('                                                                                ');
          gotoxy(1,1);
          write('Length = ',fields[i].rlen,'     Enter new length : ');
          read(fields[i].rlen);
        end;

        122:            { Scale }
        if (fields[i].rtype = 'N') then
        begin
          gotoxy(1,1);
          write('                                                                                ');
          gotoxy(1,1);
          write('Scale = ',fields[i].rscale,'    Enter new scale : ');
          read(fields[i].rscale);
        end;

        131:            { Color Menu }
          active:=2;

        { 114,133 : }

{ Color Pull-Down menu options }

        201 :           { Menu 1 }
          active:=1;

        202..203:
          fields[i].rfgnd := entry-1;
        211 : fields[i].rfgnd := 3;
        212 : fields[i].rfgnd := 4;
        213 : fields[i].rfgnd := 5;
        221 : fields[i].rfgnd := 6;
        222 : fields[i].rfgnd := 7;
        223 : fields[i].rfgnd := 8;
        231 : fields[i].rfgnd := 9;
        232 : fields[i].rfgnd := 10;
        233 : fields[i].rfgnd := 11;
        241 : fields[i].rfgnd := 12;
        242 : fields[i].rfgnd := 13;
        243 : fields[i].rfgnd := 14;
        251 : fields[i].rfgnd := 15;
        252 : fields[i].rfgnd :=  0;

    end   { case }
  end;    { while i < ndx }
end;

function min(a,b : integer) : integer;   { return the minimum of 2 numbers, or zero }
begin
  if a < b then
    begin
    if a > 0 then
      min:=a
    else min:=b;
  end
  else
    begin
    if b > 0 then
      min:=b
    else min:=a;
  end;
end;

function getvar(line : ltype) : ltype;   { breaks a token from input line }
var
  k     : integer;

begin
  incr:=0;
  if (copy(line,1,1)='!') or (copy(line,1,1)='#') then
    begin
    k:=pos(' ',line);
    if k = 0 then
      getvar:=line
    else
      begin
      incr:=k-1;
      getvar:=(copy(line,1,k-1))
    end;
  end
  else
    begin
    k:=min(pos('!',line),pos('#',line));
    if k=0 then
      getvar:=line
    else
      begin
      incr:=k-1;
      getvar:=copy(line,1,k-1);
    end;
  end;
end;

function deblank(str1 : stype) : stype;  { remove excess characters from the end of a string }
var
  str2      : stype;
  c         : char;
  i         : integer;

label 99;

begin
  str2:=str1;
  if (copy(str2,1,1)='!') or (copy(str2,1,1)='#') then
    str2:=copy(str2,2,(length(str2)-1)+1);
  for i:=length(str2) downto 1 do
    begin
    if copy(str2,i,1) <> ' ' then
      goto 99;
  end;
99:
  deblank:=copy(str2,1,i);
end;

function verify(st2 : ltype) : integer;  { return position of 1st non-space }
var
  i    : integer;
label gotit;

begin
  for i:=1 to length(st2) do
   if copy(st2,i,1) <> ' ' then
     goto gotit;

gotit:
  if i=length(st2) then  { all spaces }
    verify:=0
  else
    verify:=i;
end;


Procedure menu;   { opening menu }
var
  continue : boolean;

Begin
  continue:=true;
  active:=3;
  while continue = true do
    begin
    Clrscr;
    textcolor(15);
    highvideo;
    Gotoxy(11,4);
    Write('Copyright (c) 1985  Mark E.Johnson - MicroTools Co.');
    Gotoxy(1,2);
    Write(' ');
    Gotoxy(25,6);
    Write('TurboDraw 3.12');
    Gotoxy(27,7);
    Write('File Menu');
    Gotoxy(16,9);
    Write('Screen Input File   ');
    lowvideo;
    Gotoxy(40,9);
    Write(inname);
    highvideo;
    Gotoxy(16,10);
    Write('Pascal Output File  ');
    lowvideo;
    Gotoxy(40,10);
    Write(outname);
    highvideo;
    Gotoxy(16,11);
    Write('Library Input File  ');
    lowvideo;
    Gotoxy(40,11);
    Write(libname);
    highvideo;
    domenu(item,entry,menus[active]);
    index := active*100 + item*10 + entry;
    case index of
      300 : ans := '4';
      301 : ans := '4';
      311 : ans := '1';
      321 : ans := '2';
      331 : ans := '3';
    end;
    if ans='4' then
      continue:=false
    else
      begin
      Gotoxy(16,14);
      Write('Enter File name or <C/R>   ')
    end;
    if ans='1' then
      begin
      lowvideo;
      gotoxy(40,9);
      write('               ');
      gotoxy(40,9);
      readln(inname);
      highvideo;
      inname:=toupper(inname);
    end
    else if ans='2' then
      begin
      lowvideo;
      gotoxy(40,10);
      write('               ');
      gotoxy(40,10);
      readln(outname);
      highvideo;
      outname:=toupper(outname)
    end
    else if ans='3' then
      begin
      lowvideo;
      gotoxy(40,11);
      write('               ');
      gotoxy(40,11);
      readln(libname);
      highvideo;
      libname:=toupper(libname)
    end;
  end;
End;

procedure wrname(i : integer);    { display a variable or literal }
var
  x : integer;
begin
  for x:=1 to 20 do
    if x <= length(fields[i].rname) then
      write(copy(fields[i].rname,x,1));
end;

procedure sort;     { display and/or sort individual fields for order of input/output }
var
    hfield    : fieldrec;

    litvar,iotype,ftype : stype;
    junk      : char;
    ord1,ord2 : integer;
    i,j       : integer;
    again,l1  : boolean;

label ordl,endsort;

begin
    while true do
        begin
        clrscr;
        lowvideo;
        write('Order Field Name                Field     Mode    Type    Line   Col  Color');
        highvideo;
        j:=1;
        for i:=1 to ndx-1 do
            begin
            if j > 18 then
                begin
                j:=1;
                gotoxy(1,22);
                write('Press a key to continue ');
                read(kbd,junk);
                clrscr;
                lowvideo;
                writeln('Order Field Name                Field     Mode    Type    Line   Col  Color');
                highvideo;

            end;

            case fields[i].rtype of
              'L' : begin
                      litvar := 'Literal';
                      iotype := 'Output';
                      ftype  := 'Alpha';
                    end;
              'A' : begin
                      litvar := 'Variable';
                      ftype  := 'Alpha';
                    end;

              'N' : begin
                      litvar := 'Variable';
                      ftype  := 'Numeric';
                    end;
            end;

            case fields[i].rio of
              'I' :  iotype := 'Input';
              'O' :  iotype := 'Output';
            end;

            if fields[i].rname <> '' then  { don't display blank lines }
                begin
                gotoxy(1,j+1);
                lowvideo;
                write(fields[i].rorder:3);
                highvideo;
                gotoxy(7,j+1);
                textcolor(fields[i].rfgnd);
                wrname(i);
                textcolor(15);
                gotoxy(32,j+1);
                write(litvar);
                gotoxy(42,j+1);
                write(iotype);
                gotoxy(50,j+1);
                write(ftype);
                gotoxy(60,j+1);
                write(fields[i].rx:2);
                gotoxy(66,j+1);
                write(fields[i].ry:2);
                gotoxy(73,j+1);
                write(fields[i].rfgnd:2);
                j:=j+1;
            end;
        end;
        L1:=TRUE;
        repeat
            gotoxy(1,22);
            write('Enter field to change, or 999 to quit    ');
            lowvideo;
            gotoxy(1,23);
            write('      ');
            gotoxy(1,23);
            readln(ord1);
            highvideo;
            if ord1=999 then
                goto endsort;
            for j:=1 to ndx-1 do
                if ord1=fields[j].rorder then
                    goto ordl;
 ordl:      if ord1 = fields[j].rorder then
                l1:=FALSE;
        until l1 = false;
        ord1:=j;
        gotoxy(1,22);
        write('Place at field #                        ');
        lowvideo;
        gotoxy(1,23);
        write('     ');
        gotoxy(1,23);
        readln(ord2);
        highvideo;
        fields[ord1].rorder:=ord2;

 { Simple bubble sort is fast enough for this application }

        Again:=TRUE;
        while again = true do
            begin
            Again:=FALSE;

            for i:=1 to ndx-2 do
                begin
                If fields[i].rorder > fields[i+1].rorder Then
                    begin
                    hfield      := fields[i];
                    fields[i]   := fields[i+1];
                    fields[i+1] := hfield;
                    again:=TRUE;
                end;
            end;

        end;
     end;
    endsort:
 End;


begin { main }
  CursorNormal;

  SetVideoSeg;
  LoadMenus(Menus);
  inname:='TEST.SCR';
  outname:='TEST.PAS ';
  libname:='TD.LIB';
  beep;
retry:
  menu;
  level:=0;
  incr:=0;
  varfl:=true;
  librfl:=false;
  subrfl:=false;
  outtype:='C';
  ndx:=1;
  lineno:=1;
  assign(infile,inname);
  {$I-}
  reset(infile);
  {$I+}
  if ioresult <> 0 then
  begin
    drawbox(40,4,77,8,7,0,'[ Error ]',true);
    beep;
    writeln('Screen file not found,');
    write('Press a key to continue ');
    read(kbd,ans);
    window(40,1,77,4);
    clrscr;
    window(1,1,80,25);
    goto retry
  end;

  assign(outfile,outname);
  rewrite(outfile);

  efile:=false;
  while efile = false do
    begin
    colno:=1;
    readln(infile,line);
    if eof(infile) then
      efile:=true;
    l:=length(line);
    i:=0;
    while colno < l do
      begin
      i:=verify(line);
      if (i=0) and (length(line) > 0) then
        i:=1;
      if i > 0 then
        begin
        colno:=colno+i+incr-1;
        token:=GETVAR(copy(line,i,(length(line)-i)+1));
        j:=i+length(token);
        fields[ndx].rtype:='L';
        fields[ndx].rio  :='O';
        if copy(token,1,1) = '!' then
          begin
          fields[ndx].rio   := 'O';
          fields[ndx].rtype := 'N';
          token:=copy(token,2,length(token)-1);
        end
        else if copy(token,1,1) = '#' then
          begin
          fields[ndx].rtype := 'N';
          fields[ndx].rio   := 'I';
          token:=copy(token,2,length(token)-1);
        end;
        fields[ndx].rname:= token;
        fields[ndx].rx:=lineno;
        fields[ndx].ry:=colno;
        if fields[ndx].rtype <> 'A' then  { alphanumeric fields default to zero length }
          fields[ndx].rlen:=length(token)
        else
          fields[ndx].rlen:=0;
        fields[ndx].rscale:=0;
        if fields[ndx].rtype <> 'L' then
          fields[ndx].rfgnd:=7
        else
          fields[ndx].rfgnd:=15;
        fields[ndx].rorder:=ndx*10;
        if j >= length(line) then
          l:=0
        else
          line:=copy(line,j,(length(line)-j)+1);
        ndx:=ndx+1;
      end;
    end;
    lineno:=lineno+1;
  end;

endinp:
  close(infile);
  while true do
  begin
    active:=4;   { Set menu level }
    clrscr;
    Gotoxy(11,6);
    Write('Copyright (c) 1985  Mark E.Johnson - MicroTools Co.');
    Gotoxy(1,2);
    Write(' ');
    Gotoxy(25,8);
    Write('TurboDraw 3.12');
    gotoxy(28,9);
    write('OPTIONS');
    lowvideo;
    gotoxy(19,12);
    write('Include Library functions');
    highvideo;
    gotoxy(50,13);
    if librfl = true then
      write('Yes')
    else
      write(' No');
    lowvideo;
    gotoxy(19,14);
    write('Generate a procedure');
    highvideo;
    gotoxy(50,14);
    if subrfl = true then
    begin
      write('Yes  (');
      write(procname,')');
    end
      else write(' No');
    lowvideo;
    gotoxy(19,15);
    write('Include VAR Definitions');
    highvideo;
    gotoxy(50,15);
    if varfl = true then write('Yes')
      else write(' No');

    domenu(item,entry,menus[active]);
    index := active*100 + item*10 + entry;

    case index of
            412:    begin    { Procedure }
                      subrfl:= NOT subrfl;
                      if subrfl=true then
                        begin
                        drawbox(19,20,60,23,7,0,'[ Proc ]',false);
                        write('Enter name of procedure ');
                        textcolor(15);
                        read(procname);
                        window(19,20,60,23);
                        clrscr;
                        window(1,1,80,25);
                      end
                    end;

              411:  begin    { Include library }
                     librfl:=NOT librfl;
                     if librfl=true then
                      begin
                       assign(libfile,'TD.LIB');
                       {$I-}
                       reset(libfile);
                       {$I+}
                       if ioresult <> 0 then
                       begin
                         drawbox(20,2,55,6,7,0,'[ Error ]',true);
                         beep;
                         writeln('For this option, you must have ');
                         writeln(libname,' on the default drive.');
                         write  ('  Press a key to continue ');
                         read(kbd,ans);
                         window(20,6,55,10);
                         clrscr;
                         window(1,1,80,25);
                         librfl:=false;
                         textcolor(15);
                       end;
                     end
                   end;

             413:  varfl:=NOT varfl;
             403:  goto Generate;
             401:  Setup;
             402:  sort;

  end;
end;

       { Generate Code for TURBO PASCAL }

generate:

writeln(outfile);
writeln(outfile,'{ Start of Turbodraw code }');
  if varfl = true then
    begin
    writeln(outfile,'Var');
    for i:=1 to ndx-1 do
      begin
      if fields[i].rtype <> 'L' then
        begin
        writeln(outfile);
        write(outfile,'  ',fields[i].rname);
        if fields[i].rtype = 'N' then
        begin
          if fields[i].rscale > 0 then
            write(outfile,' : Real;')
          else
            write(outfile,' : Integer;');
        end
        else if fields[i].rtype = 'A' then
          write(outfile,' : String[',convert(fields[i].rlen),'];');
{       else
          begin
          if fields[i].rscale > 0 then
            write(outfile,' : Real;')
          else
            write(outfile,' : Integer;');
        end;
}     end;
    end;
    writeln(outfile);
  end;
  writeln(outfile);

 if librfl = true then   { output library file }
    begin
    while not eof(libfile) do     { Include library code }
      begin
      readln(libfile,line);
      writeln(outfile,line);
    end;
  close(libfile)
  end;
  if subrfl = true then
    begin
    writeln(outfile);
    writeln(outfile,'Procedure ',procname,';');
    writeln(outfile,'Begin');
    writeln(outfile,'  Clrscr;');
    writeln(outfile,'  TextColor(15);');
  end;
  for i:=1 to ndx-1 do
    begin
    if fields[i].rname > ' ' then
      writeln(outfile,'  Gotoxy(',convert(fields[i].ry),',',convert(fields[i].rx),');');
    if fields[i].rtype = 'L' then
      begin
      if fields[i].rname > ' ' then
      begin
        if lastcolor <> 15 then
        begin
          lastcolor:=15;
          writeln(outfile,'  TextColor(15);');
        end;
        writeln(outfile,'  Write(''',fields[i].rname,''');');
      end;
    end
    else if fields[i].rio = 'O' then
      begin
      tail:=convert(fields[i].rlen);
      tail:=concat(':',tail);
      if fields[i].rscale > 0 then
        tail:=concat(tail,':',convert(fields[i].rscale));
      tail:=concat(tail,');');
      if lastcolor <> fields[i].rfgnd then
      begin
        lastcolor:=fields[i].rfgnd;
        writeln(outfile,'  TextColor(',convert(fields[i].rfgnd),');');
      end;
      if (fields[i].rtype = 'A') or (fields[i].rlen = 0) then
        writeln(outfile,'  Write(',fields[i].rname,');')
      else
        writeln(outfile,'  Write(',fields[i].rname,tail)
    end

    else if fields[i].rio = 'I' then
      begin
      if lastcolor <> fields[i].rfgnd then
      begin
        lastcolor:=fields[i].rfgnd;
        writeln(outfile,'  TextColor(',convert(fields[i].rfgnd),');');
      end;
      if (fields[i].rtype = 'A') or (fields[i].rlen = 0) then
        writeln(outfile,'  Read(',fields[i].rname,');')
      else
      if fields[i].rscale > 0 then
        writeln(outfile,'  ',fields[i].rname,':=Getreal(',convert(fields[i].rlen),',',convert(fields[i].rscale),');')
      else
        writeln(outfile,'  ',fields[i].rname,':=Getint(',convert(fields[i].rlen),');');
    end;
  end;
  if lastcolor <> 15 then
    writeln(outfile,'  TextColor(15);');
  if subrfl = true then
    writeln(outfile,'End;');
  writeln(outfile,'{ End of Turbodraw Code }');
  writeln(outfile);
  close(outfile);
end.